home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Caml Light 0.7 / examples / minicaml / typeur.ml < prev   
Encoding:
Text File  |  1995-06-01  |  4.2 KB  |  113 lines  |  [TEXT/MPS ]
  1. #open "syntaxe";;
  2. #open "eval";;
  3. #open "types";;
  4. #open "synthese";;
  5.  
  6. (* L'environnement d'évaluation *)
  7.  
  8. let code_nombre n =
  9.     Val_nombre n
  10. and décode_nombre = function
  11.     Val_nombre n -> n
  12.   | _ -> raise(Erreur "entier attendu")
  13. and code_booléen b =
  14.     Val_booléenne b
  15. and décode_booléen = function
  16.     Val_booléenne b -> b
  17.   | _ -> raise(Erreur "booléen attendu");;
  18.  
  19. (* Pour transformer une fonction Caml en valeur fonctionnelle *)
  20.  
  21. let prim1 codeur calcul décodeur =
  22.   Val_primitive(function val -> codeur(calcul(décodeur val)))
  23. and prim2 codeur calcul décodeur1 décodeur2 =
  24.   Val_primitive(function
  25.     Val_paire(v1, v2) ->
  26.       codeur(calcul (décodeur1 v1) (décodeur2 v2))
  27.   | _ -> raise(Erreur "paire attendue"));;
  28.  
  29. (* L'environnement initial *)
  30.  
  31. let env_éval_initial =
  32.   ["+",  prim2 code_nombre  (prefix + ) décode_nombre décode_nombre;
  33.    "-",  prim2 code_nombre  (prefix - ) décode_nombre décode_nombre;
  34.    "*",  prim2 code_nombre  (prefix * ) décode_nombre décode_nombre;
  35.    "/",  prim2 code_nombre  (prefix / ) décode_nombre décode_nombre;
  36.    "=",  prim2 code_booléen (prefix = ) décode_nombre décode_nombre;
  37.    "<>", prim2 code_booléen (prefix <>) décode_nombre décode_nombre;
  38.    "<",  prim2 code_booléen (prefix < ) décode_nombre décode_nombre;
  39.    ">",  prim2 code_booléen (prefix > ) décode_nombre décode_nombre;
  40.    "<=", prim2 code_booléen (prefix <=) décode_nombre décode_nombre;
  41.    ">=", prim2 code_booléen (prefix >=) décode_nombre décode_nombre;
  42.    "not", prim1 code_booléen (prefix not) décode_booléen;
  43.    "read_int", prim1 code_nombre (fun x -> read_int()) décode_nombre;
  44.    "write_int", prim1 code_nombre
  45.                       (fun x -> print_int x; print_newline(); 0)
  46.                       décode_nombre];;
  47.  
  48. (* L'environnement de typage *)
  49.  
  50. let type_arithmétique = schéma_trivial
  51.   (type_flèche (type_produit type_int type_int) type_int)
  52. and type_comparaison =  schéma_trivial
  53.   (type_flèche (type_produit type_int type_int) type_bool);;
  54.  
  55. let env_typage_initial =
  56.   ["+",  type_arithmétique;     "-",  type_arithmétique;
  57.    "*",  type_arithmétique;     "/",  type_arithmétique;
  58.    "=",  type_comparaison;      "<>", type_comparaison;
  59.    "<",  type_comparaison;      ">",  type_comparaison;
  60.    "<=", type_comparaison;      ">=", type_comparaison;
  61.    "not", schéma_trivial(type_flèche type_bool type_bool);
  62.    "read_int", schéma_trivial(type_flèche type_int type_int);
  63.    "write_int", schéma_trivial(type_flèche type_int type_int)];;
  64.  
  65. (* La boucle principale *)
  66.  
  67. let boucle () =
  68.   let env_typage = ref env_typage_initial
  69.   and env_éval = ref env_éval_initial in
  70.   let flux_d'entrée = stream_of_channel std_in in
  71.   while true do
  72.     print_string "# "; flush std_out;
  73.     try
  74.       match lire_phrase flux_d'entrée with
  75.         Expression expr ->
  76.           let ty = type_exp !env_typage expr in
  77.           let rés = évalue !env_éval expr in
  78.           print_string "- : "; imprime_type ty;
  79.           print_string " = "; imprime_valeur rés;
  80.           print_newline()
  81.       | Définition déf ->
  82.           let nouvel_env_typage = type_déf !env_typage déf in
  83.           let nouvel_env_éval = évalue_définition !env_éval déf
  84.           begin match (nouvel_env_typage, nouvel_env_éval) with
  85.             (nom, schéma) :: _, (_, val) :: _ ->
  86.               print_string nom; print_string " : ";
  87.               imprime_schéma schéma;
  88.               print_string " = "; imprime_valeur val;
  89.               print_newline()
  90.           end;
  91.           env_typage := nouvel_env_typage;
  92.           env_éval := nouvel_env_éval
  93.     with
  94.       Parse_error | Parse_failure ->
  95.         print_string "Erreur de syntaxe"; print_newline()
  96.     | Conflit(ty1, ty2) ->
  97.         print_string "Incompatibilité de types entre ";
  98.         imprime_type ty1; print_string " et ";
  99.         imprime_type ty2; print_newline()
  100.     | Circularité(var, ty) ->
  101.         print_string "Impossible d'identifier ";
  102.         imprime_type var; print_string " et ";
  103.         imprime_type ty; print_newline()
  104.     | eval__Erreur msg ->
  105.         print_string "Erreur à l'évaluation: "; print_string msg;
  106.         print_newline()
  107.     | synthese__Erreur msg ->
  108.         print_string "Erreur de typage: "; print_string msg;
  109.         print_newline()
  110.   done;;
  111.  
  112. if sys__interactive then () else boucle();;
  113.